home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / nntp.el < prev    next >
Encoding:
Text File  |  1995-06-07  |  24.7 KB  |  714 lines

  1. ;;; nntp.el --- GNUS interface to NNTP servers
  2.  
  3. ;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
  4. ;;;
  5. ;; Author: Felix Lee <flee@cse.psu.edu>
  6. ;; Version: !Id: nntp.el,v 1.10 1993/02/04 18:23:39 flee Exp !
  7. ;; Modified by jwz.
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify it
  12. ;; under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; XEmacs is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Code:
  26.  
  27. (require 'gnus)        ; for the (poorly named) 'nntp-' accessor macros.
  28. (require 'chat)
  29. (or (fboundp 'open-network-stream) (require 'tcp))
  30.  
  31. (defvar nntp/rcs-revision (purecopy "!Revision: 1.10.3 !"))
  32.  
  33. (defvar nntp/default-nntp-port (purecopy "nntp")
  34.   "The default tcp port to use for nntp connections.")
  35.  
  36. (defun nntp-last (x)
  37.   "Returns the last link in the list LIST."
  38.   (while (cdr x)
  39.     (setq x (cdr x)))
  40.   x)
  41.  
  42. ;;;;;;;;;;;;;;;;
  43. ;;; NNTP state.
  44.  
  45. ;; Right now, we're assuming we only talk to one NNTP server at a
  46. ;; time.  It might be nice to do multiple NNTP connections, but
  47. ;; there's no point in doing this from the bottom up.
  48.  
  49. ;; (To handle multiple connections, you need to create connection
  50. ;; handles that you pass around.  Ideally, nnspool et al would be
  51. ;; just different types of connection handles.)
  52.  
  53. (defvar nntp/connection nil
  54.   "The current NNTP connection.")
  55.  
  56. ;; XEmacs addition
  57. (defvar nntp/group nil
  58.   "The most-recently-selected NNTP group.")
  59.  
  60. ;;; jwz: call this nntp-status-string instead of nntp/error-message because
  61. ;;; existing code uses that variable (in particular, nnspool.el and mhspool.el
  62. ;;; set it.)
  63. (defvar nntp-status-string nil
  64.   "The error message from the last NNTP command.  'nil if no error.
  65. Don't use this, call the function `nntp-status-message' instead.")
  66.  
  67. (defvar nntp/can-xover t
  68.   "Does this server understand the XOVER command?  (Computed.)")
  69.  
  70. ;; XEmacs addition
  71. (defvar nntp/inhibit-xover nil
  72.   "If you have XOVER but it doesn't work, set this to t.")
  73.  
  74. ;;;;;;;;;;;;;;;;
  75. ;;; The GNUS interface.
  76.  
  77. ;; These are the symbols that GNUS knows about and expects.
  78.  
  79. ;; The interaction between GNUS and nntp.el (or nnspool.el) is a
  80. ;; little messy and not particularly well defined.
  81.  
  82. (defvar nntp-version
  83.   (purecopy
  84.    (concat "flee/nntp/Lucid " (substring nntp/rcs-revision 11 -2))))
  85.  
  86. (defvar nntp-server-buffer nil
  87.   "Buffer that GNUS looks at when it wants data.")
  88.  
  89. ;; XEmacs addition
  90. (defvar nntp-authinfo-string nil
  91.   "*String sent to NNTP server if the connection fails.")
  92.  
  93. (defun nntp-open-server (host service)
  94.   "Start a connection to the given HOST and SERVICE.  Returns true
  95. if successful."
  96.   ;; XXX already open?
  97.   (or service (setq service nntp/default-nntp-port))
  98.   (setq nntp-status-string nil)
  99.   (setq nntp/can-xover (not nntp/inhibit-xover))  ; XEmacs change
  100.   (setq nntp-server-buffer (generate-new-buffer "*nntp*"))
  101.   ;;(buffer-flush-undo nntp-server-buffer)
  102.   (buffer-disable-undo nntp-server-buffer)
  103.   (setq nntp/group nil) ; XEmacs addition
  104.   (setq nntp/connection
  105.     (open-network-stream "nntp" nntp-server-buffer host service))
  106.   (set-process-sentinel nntp/connection 'nntp/sentinel)
  107.   (process-kill-without-query nntp/connection)
  108.  
  109.   (let ((code (nntp/response)))
  110.  
  111.     ;; XEmacs addition: with some INN servers, we need to do this to convince
  112.     ;; it to behave in the conventional way and not assume we want to do a
  113.     ;; batch transfer of news.  With older NNTP servers, this will provoke a
  114.     ;; "500 unknown command", which we can simply ignore.
  115.     (nntp/command "MODE READER")
  116.     (nntp/response) ; ignored.
  117.  
  118.     (or (eq code 200) (eq code 201)
  119.     ;; XEmacs change: if it fails, send AUTHINFO and try once more.
  120.     (and nntp-authinfo-string
  121.          (progn
  122.            (nntp/command "AUTHINFO" nntp-authinfo-string)
  123.            (setq code (nntp/response))
  124.            (or (eq code 200) (eq code 201)))))))
  125.            
  126.  
  127. (defun nntp-server-opened ()
  128.   "Are we currently connected?"
  129.   ;; if the buffer has died on us, kill all the rest.
  130.   (if (and nntp/connection
  131.        (or (null nntp-server-buffer)
  132.            (null (buffer-name nntp-server-buffer))))
  133.       (nntp-close-server))
  134.   (and nntp/connection
  135.        (memq (process-status nntp/connection) '(run open))))
  136. ;; XXX should we add stopped to this list?
  137.  
  138. (defun nntp-close-server ()
  139.   "Terminate the connection.  Returns nothing."
  140.   (let ((proc nntp/connection)
  141.     (buffer nntp-server-buffer))
  142.     (setq nntp/connection nil)
  143.     (setq nntp/group nil) ; XEmacs addition
  144.     (setq nntp-server-buffer nil)
  145.     (and proc (delete-process proc))
  146.     (and buffer (kill-buffer buffer))))
  147.  
  148. (defun nntp-status-message ()
  149.   "Returns the error message from the last NNTP request."
  150.   ;; jwz: return "" instead of "okay" just in case old code expected that.
  151.   (or nntp-status-string ""))
  152.  
  153. (defun nntp-request-list ()
  154.   "Retrieve the list of newsgroups into 'nntp-server-buffer.
  155. Returns true if successful."
  156.   (nntp/command "LIST")
  157.   (if (eq (nntp/response) 215)
  158.       ;; We don't do any text format conversion here.  It's wasted
  159.       ;; effort, since the text needs to be parsed by GNUS anyway.
  160.       (nntp/wait-for-text)))
  161.  
  162. (defun nntp-request-group (group)
  163.   "Select group GROUP.  Returns true if successful."
  164.   (nntp/command "GROUP" group)
  165.   (if (not (eq (nntp/response) 211))
  166.       nil
  167.     (setq nntp/group group) ; XEmacs addition
  168.     t))
  169.  
  170. (defun nntp-request-article (id)
  171.   "Retrieve article ID (either a number or a message-id) into
  172. 'nntp-server-buffer.  Returns true if successful."
  173.   (and (numberp id) (setq id (int-to-string id)))
  174.   (nntp/command "ARTICLE" id)
  175.   (if (eq (nntp/response) 220)
  176.       (nntp/get-text)))
  177.  
  178. (defun nntp-request-post ()
  179.   "Modify and post the current buffer.  Returns true if successful."
  180.   ;; The trick here is we want to make sure the conversation is in a
  181.   ;; sane state even if we're interrupted in middle of transmission.
  182.   ;; Right now, we just prematurely terminate the posting.  While this
  183.   ;; isn't ideal, it's better than continually adding junk to the end.
  184.   ;; The problem is NNTP doesn't let you abort a posting.
  185.   ;; XXX A better approach is to open a new connection for posting,
  186.   ;; but this is going to be slower, unless you anticipate the user by
  187.   ;; opening the connection early.
  188.   (nntp/command "POST")
  189.   (if (eq (nntp/response) 340)
  190.       (let ( (finished nil) )
  191.     (unwind-protect
  192.         (progn
  193.           (nntp/unix-to-smtp-text)
  194.           (process-send-region nntp/connection (point-min) (point-max))
  195.           (setq finished t)
  196.           (eq (nntp/response) 240))
  197.       (or finished
  198.           (process-send-string nntp/connection "\r\n.\r\n")
  199.           nil)))))
  200.  
  201. ;; XEmacs: ckd addition to support by-ID retrieval
  202. (defun nntp-retrieve-headers-by-id (messageid)
  203.   "Returns the header data for MESSAGE-ID.
  204. MESSAGE-ID is a string like \"<12345@foo.com>\"."
  205.   (and messageid
  206.        (let ((result nil))
  207.      (message "NNTP: retrieving headers...")
  208.      ;; ckd: strictly speaking, nntp/headers wants a sequence but the
  209.      ;; underlying NNTP command (HEAD) doesn't actually care, so this
  210.      ;; still works.
  211.      (setq result (nntp/headers messageid))
  212.      (message "NNTP: retrieving headers...done")
  213.      result)))
  214.  
  215. (defun nntp-retrieve-headers (sequence)
  216.   "Returns the header data for SEQUENCE in the current group.
  217. SEQUENCE is a sorted list of article numbers.
  218. XXX describe the return value."
  219.   (and sequence
  220.        (let ((result nil))
  221.      (message "NNTP: retrieving headers...")
  222.      (if nntp/can-xover
  223.          (setq result (nntp/try-xover sequence)))
  224.      (if (not nntp/can-xover)
  225.            (setq result (nntp/headers sequence)))
  226.      (message "NNTP: retrieving headers...done")
  227.      result)))
  228.  
  229. ;;;;;;;;;;;;;;;;
  230. ;;; Talking to the NNTP server.
  231.  
  232. (defun nntp/sentinel (proc delta)
  233.   (or (nntp-server-opened)
  234.       (error "NNTP connection closed.")))
  235.  
  236. (defun nntp/clear ()
  237.   ;; XXX This resynchronization is imperfect, but is probably good
  238.   ;; enough for normal use.
  239.   (chat/delete-pending-data nntp/connection))
  240.  
  241. (defun nntp/command (&rest strings)
  242.   "Start a new NNTP command."
  243.   (nntp/clear)
  244.   (process-send-string
  245.    nntp/connection
  246.    (concat (mapconcat 'identity strings " ") "\r\n")))
  247.  
  248. ;;;;;;;;;;;;;;;;
  249. ;;; Reading from the NNTP server.
  250.  
  251. ;; This is almost 4x faster than (string-to-int (buffer-substring ... ))
  252. ;; primarily because of garbage collection.  -jwz
  253. (defmacro nntp/read-integer (&optional point move-p)
  254.   (` ((, (if move-p 'progn 'save-excursion))
  255.       (,@ (if point (list (list 'goto-char point))))
  256.       (if (and (<= (following-char) ?9)
  257.            (>= (following-char) ?0))
  258.       (read (current-buffer))
  259.     0))))
  260.  
  261. (defun nntp/response ()
  262.   "Wait for an NNTP response and return the response code.  Also sets
  263. 'nntp-status-string."
  264.   ;; XXX Emacs 18.xx has a bug that turns undo back on after a gc, so
  265.   ;; we continually flush undo here.
  266.   ;;(buffer-flush-undo nntp-server-buffer)
  267.   (chat/with-data-until-string "\n" nntp/connection
  268.     (let ((code (nntp/read-integer (point-min))))
  269.       ;; Codes 400 and up are error conditions.
  270.       (setq nntp-status-string
  271.         (and (<= 400 code)
  272.          (buffer-substring (+ (point-min) 4) (- (point-max) 2))))
  273.       code)))
  274.  
  275. (defun nntp/wait-for-text ()
  276.   "Wait for an NNTP text response.  Returns true."
  277.   (chat/wait-for-dot-crlf nntp/connection))
  278.  
  279. (defun nntp/get-text ()
  280.   "Wait for an NNTP text response and convert it to Unix text format.
  281. Returns true."
  282.   (nntp/wait-for-text)
  283.   (save-excursion
  284.     (set-buffer nntp-server-buffer)
  285.     (nntp/smtp-to-unix-text))
  286.   t)
  287.  
  288. ;;;;;;;;;;;;;;;;
  289. ;;; Handling the funny dot-CRLF text format used by SMTP/NNTP.
  290.  
  291. (defun nntp/smtp-to-unix-text ()
  292.   "Convert the current buffer from SMTP text format to Unix text
  293. format.  Modifies point.  Returns nothing."
  294.   (goto-char (point-min))
  295.   (while (not (eobp))
  296.     (if (eq (following-char) ?.)
  297.     (delete-char 1))
  298.     (end-of-line)
  299.     (if (eq (preceding-char) ?\r)
  300.     (delete-char -1))
  301.     (forward-char))
  302.   ;; Delete the last line, which had the dot-crlf terminator.
  303.   (backward-char)
  304.   (if (eq (preceding-char) ?\n)
  305.       (delete-char 1))
  306.   )
  307.  
  308. (defun nntp/unix-to-smtp-text ()
  309.   "Convert the current buffer form Unix text format to SMTP text
  310. format.  Modifies point.  Returns nothing."
  311.   (goto-char (point-min))
  312.   (while (not (eobp))
  313.     (if (eq (following-char) ?.)
  314.     (insert ?.))
  315.     (end-of-line)
  316.     (insert ?\r)
  317.     (forward-line))
  318.   ;; Add the terminator, but first insert a CRLF if necessary.
  319.   (or (bobp)
  320.       (eq (preceding-char) ?\n)
  321.       (insert "\r\n"))
  322.   (insert ".\r\n"))
  323.  
  324. ;;;;;;;;;;;;;;;;
  325. ;;; Fetch headers using XOVER.
  326.  
  327. ;; XXX We could probably try splitting a sequence into segments and
  328. ;; sending multiple XOVER commands, one for each segment.  However,
  329. ;; this is a little more expensive for the news server to process, and
  330. ;; mostly just reduces network traffic.  There isn't much difference
  331. ;; in response, unless you're in the habit of leaving 100+ article
  332. ;; gaps.  A couple hundred extra overview lines are unnoticeable on a
  333. ;; Sun SLC.
  334.  
  335. ;; XXX In general, maybe we should have a gap threshhold: if a gap is
  336. ;; larger than N, split it into two XOVER requests, but the actual
  337. ;; tradeoffs are more complex than that.  This is really a flaw in
  338. ;; XOVER; you should be able to give XOVER a monotonically increasing
  339. ;; sequence of ranges, which is something that can be processed
  340. ;; efficiently.
  341.  
  342. ;; XXX There's an unhappy synchronization problem here with C News.
  343. ;; The bounds in the active file are updated before the overview data
  344. ;; is updated, which may not happen until minutes later.  If you read
  345. ;; the active file and enter a newsgroup soon after it receives new
  346. ;; articles, then the overview fetch will leave out the new articles.
  347. ;; GNUS will wrongly conclude that the articles don't exist, mark them
  348. ;; as read, and you'll never see them.
  349.  
  350. (defun nntp/try-xover (sequence)
  351.   "Try using the XOVER command to retrieve headers."
  352.   (let ((lo (car sequence))
  353.     (hi (car (nntp-last sequence))))
  354.     (nntp/command "XOVER" (concat (int-to-string lo) "-" (int-to-string hi)))
  355.     (if (eq (nntp/response) 224)
  356.     (chat/with-data-until-dot-crlf nntp/connection
  357.       (nov/parse sequence))
  358.       (setq nntp/can-xover nil)
  359.       nil)))
  360.  
  361. ;;;;;;;;;;;;;;;;
  362. ;;; News overview parsing.
  363.  
  364. ;; XXX This section isn't really nntp-specific.  It probably could be
  365. ;; a separate module by itself.
  366.  
  367. ;; Small changes to this code can have large impact on performance.
  368.  
  369. ;; You'd think that using skip-chars-forward would be faster than
  370. ;; search-forward, but for some reason it ends up marginally slower.
  371. ;; I suspect it's because the setup overhead for both is about the
  372. ;; same, but the inner loop for search-forward is much more carefully
  373. ;; coded.
  374.  
  375. (defmacro nov/skip-field ()
  376.   '(search-forward "\t" eol 'end))
  377.  
  378. (defmacro nov/field ()
  379.   '(buffer-substring
  380.     (point)
  381.     (progn (nov/skip-field) (1- (point)))))
  382.  
  383. (defun nov/parse (sequence)
  384.   "Parse the news overview data in the current buffer, and return a
  385. list of headers that match SEQUENCE (see 'nntp-retrieve-headers)."
  386.   (let ( (number nil)
  387.      (header nil)
  388.      (headers nil)
  389.      (eol nil) )
  390.     (goto-char (point-min))
  391.     (while (and sequence (not (eobp)))
  392.       (setq number (nntp/read-integer nil t))
  393.  
  394.       ;; INN can report XOVER information *if* it is set up to do so.
  395.       ;; However, if it is not configured to do so, instead of replying
  396.       ;; to XOVER with some status code that we can detect, it responds
  397.       ;; with 224.  However, the data that it returns is useless to us:
  398.       ;; it's just a list of article numbers, with no other fields
  399.       ;; present.
  400.       ;;
  401.       ;; So, if after reading the number, the next character is not a
  402.       ;; tab, we must be in this state.  At that point, give up on XOVER
  403.       ;; and return nil.
  404.       ;;
  405.       ;; However, a working XOVER server will return an empty response
  406.       ;; for articles which don't exist - compare to the above-bug, which
  407.       ;; returns a line containing only an article number.  Be careful
  408.       ;; not to turn off XOVER in that case.
  409.       ;;
  410.       ;; ckd says that this bug is fixed in INN 1.4 and later: nnrpd
  411.       ;; will generate XOVER information the fly if there is no overview
  412.       ;; file.
  413.       ;;
  414.       (if (not (= (following-char) ?\t))
  415.       (if (= (following-char) ?.)
  416.           ;; EXCEPT if the next character is "." which means we are at
  417.           ;; the end of the XOVER data.  In that case we probably tried
  418.           ;; to get a cancelled article.  Clear the sequence and exit.--ckd
  419.           (progn
  420.         (setq sequence nil)
  421.          (goto-char (point-max)))
  422.         ;; We're losing.
  423.         (setq sequence nil
  424.           headers nil
  425.           nntp/can-xover nil)
  426.         (goto-char (point-max))
  427.         )
  428.  
  429.     ;; else, the XOVER data appears to be for real.
  430.  
  431.     (while (and sequence (< (car sequence) number))
  432.       (setq sequence (cdr sequence)))
  433.     (if (and sequence (eq number (car sequence)))
  434.         (progn
  435.           (setq sequence (cdr sequence))
  436.           (save-excursion
  437.         (end-of-line)
  438.         (setq eol (point)))
  439.           ;; header: [num subject from xref lines date id refs]
  440.           ;; overview: [num subject from date id refs lines chars misc]
  441.           (setq header (make-vector 8 nil))
  442.           (nntp-set-header-number      header number)
  443.           (forward-char)          ; move past the "\t"
  444.           (nntp-set-header-subject      header (nov/field))
  445.           (nntp-set-header-from      header (nov/field))
  446.           (nntp-set-header-date      header (nov/field))
  447.           (nntp-set-header-id      header (nov/field))
  448.           (nntp-set-header-references header (nov/field))
  449.           (nov/skip-field)
  450.           ;; #### this could benefit from using nntp/read-integer
  451.           (nntp-set-header-lines      header (string-to-int (nov/field)))
  452.           (backward-char)
  453.           (if (search-forward "\txref: " eol t)
  454.           (nntp-set-header-xref      header (nov/field)))
  455.           (setq headers (cons header headers))
  456.           ))
  457.     (forward-line)
  458.     )
  459.       )
  460.     (setq headers (nreverse headers))
  461.     headers))
  462.  
  463. ;;;;;;;;;;;;;;;;
  464. ;;; A workaround for missing Xrefs in the overview data.
  465.  
  466. ;(defun nntp/add-to-hook (hook-name value)
  467. ;  (let ((hook nil))
  468. ;    (if (boundp hook-name)
  469. ;    (setq hook (symbol-value hook-name)))
  470. ;    (if (or (subrp hook)
  471. ;        (and hook (symbolp hook))
  472. ;        (and (listp hook) (eq (car hook) 'lambda)))
  473. ;    (setq hook (list hook)))
  474. ;    (or (memq value hook)
  475. ;    (setq hook (cons value hook)))
  476. ;    (set hook-name hook)))
  477.  
  478. ;(nntp/add-to-hook
  479. ; 'gnus-Article-prepare-hook
  480. ; 'nntp/article-get-xrefs)
  481.  
  482. (add-hook 'gnus-article-prepare-hook 'nntp/article-get-xrefs)
  483.  
  484.  
  485. (defvar gnus-current-headers nil)    ; from gnus.el
  486.  
  487. (defun nntp/article-get-xrefs ()
  488.   "Fill in the Xref value in 'gnus-current-headers, if necessary.
  489. This is meant to be called in 'gnus-Article-prepare-hook."
  490.   (or gnus-digest-mode
  491.       (nntp-header-xref gnus-current-headers)
  492.       (let ((case-fold-search t))       ;XEmacs, was nil
  493.     (goto-char (point-min))
  494.     (search-forward "\n\n" nil 'end)
  495.     (save-restriction
  496.       (narrow-to-region (point-min) (point))
  497.       (goto-char (point-min))
  498.       (if (or (and (eq (downcase (following-char)) ?x)
  499.                (looking-at "Xref:"))
  500.           (search-forward "\nXref:" nil t))
  501.           (progn
  502.         (goto-char (match-end 0))
  503.         (forward-char)
  504.         (aset gnus-current-headers 3
  505.               (buffer-substring
  506.                (point) (progn (end-of-line) (point))))
  507.         ))))))
  508.  
  509. ;;;;;;;;;;;;;;;;
  510. ;;; Fetch headers using HEAD.
  511.  
  512. (defun nntp/headers (sequence)
  513.   (nntp/clear)
  514.   (nntp/send-head-requests sequence)
  515.   (nntp/parse-headers sequence))
  516.  
  517. (defun nntp/send-head-requests (sequence)
  518.   (message "NNTP: requesting headers...")
  519.   (let ((L (length sequence))
  520.     (count 0))
  521.     (while sequence
  522.       (process-send-string
  523.        nntp/connection
  524.        (concat "HEAD " (car sequence) "\r\n"))
  525.       (if (= 0 (% count 5000))
  526.       (gnus-lazy-message "NNTP: requesting headers... %d%%" (/ count L)))
  527.  
  528.       ;; XEmacs change: in order to avoid a potential deadlock, it is necessary
  529.       ;; to synchronize with the server occasionally.  At first I thought to do
  530.       ;; this by ressurecting the `nntp-maximum-request' variable, but that
  531.       ;; seems not to be enough.  Consider the following situation:
  532.       ;; - send N "head" requests
  533.       ;; - wait for a reply; get a bunch of lines back for the first N/2
  534.       ;;   requests.  As soon as no more input is available (because the
  535.       ;;   the server has momentarily stopped sending for whatever reason)
  536.       ;;   we continue
  537.       ;; - send N more "head" requests
  538.       ;; - get back another N/2 responses.
  539.       ;; In this way, we can easily fill up the buffer between us and the
  540.       ;; server, and get a deadlock, no matter what the value of
  541.       ;; `nntp-maximum-request' so long as it is greater than one.
  542.       ;;
  543.       ;; So, after each HEAD request, we wait for a reply for that request.
  544.       ;; This stinks.  It would be better to send N head requests, and then
  545.       ;; block waiting for N responses to come in.  However, the current
  546.       ;; structure of this code (in particular the implementation of
  547.       ;; nntp/parse-headers, using chat/with-data-until-string) makes that
  548.       ;; tricky.
  549.       ;;
  550.       ;; XEmacs: no focus-change surprises here
  551.       (save-excursion (accept-process-output nntp/connection))
  552.  
  553.       (setq count (+ count 100))
  554.       (setq sequence (cdr sequence))))
  555.   )
  556.  
  557. (defun nntp/parse-headers (sequence)
  558.   (message "NNTP: parsing headers...")
  559.   (let ((headers nil)
  560.     (code nil)
  561.     (L (length sequence))
  562.     (count 0))
  563.     (while sequence
  564.       (chat/with-data-until-string "\n" nntp/connection
  565.     (setq code (nntp/read-integer (point-min))))
  566.       (if (eq code 221)
  567.       (chat/with-data-until-dot-crlf nntp/connection
  568.         (setq headers (cons (nntp/parse-header (car sequence)) headers)))
  569.     (chat/with-buffer-of nntp/connection        ; jwz: added this
  570.           (forward-line)))
  571.       (if (= 0 (% count 5000))
  572.       (gnus-lazy-message "NNTP: parsing headers... %d%%" (/ count L)))
  573.       (setq count (+ count 100))
  574.       (setq sequence (cdr sequence)))
  575.     (nreverse headers)))
  576.  
  577. ;;; #### should this be inline?
  578. (defun nntp/header-value ()
  579.   (goto-char (match-end 0))
  580.   (skip-chars-forward "\t ")
  581.   (buffer-substring
  582.    (point)
  583.    (progn
  584.      (while
  585.      (progn
  586.        (end-of-line)
  587.        (if (eq (preceding-char) ?\r)
  588.            (delete-char -1))
  589.        (forward-char)
  590.        (memq (following-char) '(?\t ? )))
  591.        (delete-char -1)
  592.        (delete-char 1)
  593.        (insert ? ))
  594.      (1- (point))))
  595.   )
  596.  
  597. (defun nntp/parse-header (number)
  598.   (let ((header (make-vector 8 nil))
  599.     (case-fold-search t)
  600.     char)
  601.     ;; The old nntp.el used to always use 0 as the message number of
  602.     ;; articles which were requested by message-id.  It might make more
  603.     ;; sense to put the message-id in there, but it breaks things.  --jwz
  604.     (aset header 0 (if (numberp number) number 0))
  605.  
  606.     (aset header 4 0)
  607.     (while (not (eobp))
  608.       ;; header: [num subject from xref lines date id refs]
  609.       (if (not (looking-at "subject:\\|from:\\|xref:\\|lines:\\|date:\\|message-id:\\|references:"))
  610.       (forward-line)
  611.     (setq char (downcase (following-char))) ; XEmacs addition
  612.     (cond
  613.      ((eq char ?s)
  614.       (nntp-set-header-subject header (nntp/header-value)))
  615.      ((eq char ?f)
  616.       (nntp-set-header-from header (nntp/header-value)))
  617.      ((eq char ?x)
  618.       (nntp-set-header-xref header (nntp/header-value)))
  619.      ((eq char ?l)
  620.       ;; #### this could benefit from using nntp/read-integer
  621.       (nntp-set-header-lines header (string-to-int (nntp/header-value))))
  622.      ((eq char ?d)
  623.       (nntp-set-header-date header (nntp/header-value)))
  624.      ((eq char ?m)
  625.       (nntp-set-header-id header (nntp/header-value)))
  626.      ((eq char ?r)
  627.       (nntp-set-header-references header (nntp/header-value)))
  628.      ))
  629.       )
  630.     ;; XEmacs addition: must have a subject and sender.
  631.     (or (nntp-header-subject header) (nntp-set-header-subject header ""))
  632.     (or (nntp-header-from header) (nntp-set-header-from header ""))
  633.  
  634.     ;; XEmacs addition: if this article was requested by message id, try to
  635.     ;; figure out what its article number in the current group is.  This can
  636.     ;; only succeed if the article is a crosspost, or if this NNTP server adds
  637.     ;; an "Xref:" field to all articles (some do.)  In any event, if this can
  638.     ;; succeed, it returns a more meaningful result, so give it a try.  The
  639.     ;; consing and funcalls in here are not a big deal because the only time
  640.     ;; articles are retrieved by message-id is when we're only getting a
  641.     ;; single article.
  642.     (and (not (numberp number))
  643.      (stringp (nntp-header-xref header))
  644.      nntp/group
  645.      (string-match (concat "[ \t]"
  646.                    (regexp-quote nntp/group)
  647.                    ":\\([0-9]+\\)")
  648.                (nntp-header-xref header))
  649.      (setq number
  650.            (aset header 0 (car (read-from-string (nntp-header-xref header)
  651.                              (match-beginning 1)
  652.                              (match-end 1))))))
  653.  
  654.     ;; XEmacs change from ckd: if the XPATH command is available, it will give
  655.     ;; us a list of paths for the article.  This means even if it is only
  656.     ;; posted to one group, and has no Xref, if that group is the current
  657.     ;; group then we can get a useful article number.  XPATH response is in
  658.     ;; the form '223 alt/foo/bar/350 alt/baz/ugh/1023'.  This serves as an
  659.     ;; extra fallback for the 'Xref' trick above.  XXX this code will do the
  660.     ;; wrong thing with alt.foo.bar if there also exists an alt.foo-bar group
  661.     ;; (because it uses the group name's dots as regexp characters).  We
  662.     ;; really should change . to / and use regexp-quote, but I haven't coded
  663.     ;; that part yet -- ckd 930124
  664.     ;;
  665.     ;; jwz asks: what NNTP servers always provide Xref, and which provide
  666.     ;; XPATH (and is that standardized at all) and is ther any overlap?
  667.     ;;
  668. ;; Ok, I've disabled this because it breaks the world when -retrieve-headers
  669. ;; or -retrieve-headers-by-id are called with more than one message ID.  You
  670. ;; can't go and issue another command before you're done parsing the rest on
  671. ;; the queue because that throws all that data away!!  -jwz
  672. ;    (and (not (numberp number))
  673. ;     (let ((code nil)
  674. ;           (response-string nil))
  675. ;       (and (= 0 (aref header 0))
  676. ;        nntp/group
  677. ;        (progn
  678. ;          (nntp/command "XPATH" (aref header 6))
  679. ;          ;; we can't use nntp/response since we need the text of
  680. ;          ;; the line
  681. ;          (chat/with-data-until-string
  682. ;           "\n" nntp/connection
  683. ;           (setq code (nntp/read-integer (point-min))
  684. ;             response-string
  685. ;             (concat " "
  686. ;                 (buffer-substring (+ (point-min) 4)
  687. ;                           (- (point-max) 2))
  688. ;                 " "))))
  689. ;        (eq code 223)
  690. ;        (string-match (concat " " nntp/group "/\\([0-9]+\\) ")
  691. ;                  response-string)
  692. ;        (aset header 0 (car (read-from-string response-string
  693. ;                              (match-beginning 1)
  694. ;                              (match-end 1)))))))
  695.     header))
  696.  
  697. ;;; ADDED for gnus3.15
  698.  
  699. (defun nntp-request-list-newsgroups ()
  700.   "List newsgroups (defined in NNTP2)."
  701.   (nntp/command "LIST NEWSGROUPS")
  702.   (if (eq (nntp/response) 215)
  703.       (nntp/wait-for-text)))
  704.  
  705. (defun nntp-request-list-distributions ()
  706.   "List distributions (defined in NNTP2)."
  707.   (nntp/command "LIST DISTRIBUTIONS")
  708.   (if (eq (nntp/response) 215)
  709.       (nntp/wait-for-text)))
  710.  
  711. (provide 'nntp)
  712.  
  713. ;;; nntp.el ends here
  714.